PC-X 1997 October/pcx14_9710.iso/swag/files.swg/0102_Very Nice File Handling For BP.pas

Pascal/Delphi Source File | 1997-03-04 | 36.6 KB | 1,519 lines

{$A+,B-,D-,E-,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}

Unit UFile95;

{A lot of declarations in this unit belong in other units, such as
 Move32 (UMemory); TBoolean/TByte/TChar - UGlobal. Unit was modified to
 be standalone.}


(* **************************************************************
     TO COMPILE  UFILE95  YOU NEED TO COMPILE THE  UMULTI  UNIT
         WHOSE SOURCE CAN BE FOUND AT THE END OF THIS FILE
   **************************************************************
                  PLEASE PUBLISH THIS IN THE SWAG
   ************************************************************** *)


Interface {Nothing!}

Const Author = 'UFile95 v6.2, 05-Feb-97, 1995-1997.'+
               'Written by Gil Shapira.'+
               'Bug or other reports to:  [e-mail]';

{Nicer looks ;-) }
Type TBoolean = Boolean;
     TPointer = Pointer;
     TChar = Char;
     TByte = Byte;
     TWord = Word;
     THalf = ShortInt;
     TInt = Integer;
     TDouble = LongInt;

Type THandle = TWord;
     TError = TWord;

{File modes}
Const fmRead = 0;
      fmWrite = 1;
      fmReadWrite = 2;
      fmDenyAll = 16;
      fmDenyWrite = 32;
      fmDenyRead = 48;
      fmDenyNone = 64;

{File seek origins}
Const foStart = 0;
      foCurrent = 1;
      foEnd = 2;

{File attributes}
Const faReadOnly = 1;
      faHidden = 2;
      faSystem = 4;
      faVolume = 8;
      faDirectory = 16;
      faArchive = 32;
      faAnyFile = 63;

{File parts}
Const fcExtension = 1;
      fcFileName = 2;
      fcDirectory = 4;
      fcWildcards = 8;

{Search record for DOS interrupt 21h}
Type PSearch = ^TSearch;
     TSearch = Record
                SearchDrive: TChar;
                SearchTemplate: Array [1..11] Of TByte;
                SearchAttr: TByte;
                DirEntry: TWord;
                StartCluster: TWord;
                Reserved: Array [1..4] Of TByte;
                Attr: TByte;
                Time: TWord;
                Date: TWord;
                Size: TDouble;
                Name: Array [1..13] Of TChar;
               End;

{Search record for Windows '95 interrupt 21h}
Type PSearch95 = ^TSearch95;
     TSearch95 = Record
                  Handle: TWord;
                  Attr: TDouble;
                  Creation: Comp;
                  LastAccess: Comp;
                  LastModify: Comp;
                  SizeHi: TDouble;
                  SizeLo: TDouble;
                  Reserved: Array [1..8] Of TByte;
                  Name: Array [0..259] Of TChar;
                  ShortName: Array [0..13] Of TChar;
                 End;

Var LockLevel,
    FileMode,
    FindAttr,
    CopyAttr,
    DeleteAttr,
    CreateAttr: TWord;
    flError: TError;
    isError,
    Using95: TBoolean;

 {Creates a new directory; only ONE directory at a time.}
Procedure CreateDir(PathName: PChar);
 {Removes an existing directory; should not be current directory}
Procedure RemoveDir(PathName: PChar);
 {Makes the specified directory the current directory,
  without changing the current drive}
Procedure ChangeDir(PathName: PChar);
 {Returns the current directory path}
Procedure CurrentDir(CurDir: PChar);
 {Makes the specified directory the current directory,
  and changes the current drive if needed}
Procedure ChangePath(PathName: PChar);
 {Creates a virtual drive for the path specified; should be
  used ONLY under Windows '95}
Procedure Subst(Drive: TChar; PathName: PChar);
 {Returns the path for the virtual drive specified; should be
  used ONLY under Windows '95}
Procedure QuerySubst(Drive: TChar; Var PathName: PChar);
 {Terminates the virtual drive association; should be
  used ONLY under Windows '95}
Procedure DeleteSubst(Drive: TChar);
 {Creates a new file}
Function Create(FileName: PChar): THandle;
 {Replaces an existing file, erasing its content}
Function Replace(FileName: PChar): THandle;
 {Opens an existing file}
Function Open(FileName: PChar): THandle;
 {Duplicated a file handle}
Function Duplicate(Handle: THandle): THandle;
 {Changes the position in the file; use the file origin
  constants for Origin}
Function Seek(Handle: THandle; Position: TDouble; Origin: TByte): TDouble;
 {Returns the current position in the file}
Function FilePos(Handle: THandle): TDouble;
 {Returns the size of the file}
Function FileSize(Handle: THandle): TDouble;
 {Splits the path to directory, filename (8), and extension (4)}
Function FSplit(Path,Dir,Name,Ext: PChar): TByte;
 {Expands a short/long filename}
Procedure FExpand(Path,Result: PChar);
 {Return the file attributes}
Function GetFileAttr(FileName: PChar): TByte;
 {Changes the file attributes}
Procedure SetFileAttr(FileName: PChar; Attr: TByte);
 {Returns a file's true name}
Procedure TrueName(FileName,TrueFileName: PChar);
 {Returns a file's short name (8.3); should be used only
  under Windows '95}
Procedure ShortName(FileName,ShortFileName: PChar);
 {Generates a short name (8.3) for a long file name; should
  be used only under Windows '95}
Procedure LongToShort(FileName,ShortFileName: PChar);
 {Deletes a file}
Procedure Delete(FileName: PChar);
 {Renames a file; can move a file between directories on the same drive}
Procedure Rename(FileName,NewName: PChar);
 {Deletes any bytes from the position in the file to its end}
Procedure Truncate(Handle: THandle);
 {Flushes any file buffers}
Procedure Commit(Handle: THandle);
 {Closes a file, writing any changes}
Procedure Close(Handle: THandle);
 {Reads a block of bytes to a buffer}
Function BlockRead(Handle: THandle; Var Buff; Count: TWord): TWord;
 {Writes a block of bytes to a file}
Function BlockWrite(Handle: THandle; Var Buff; Count: TWord): TWord;
 {Locks a drive to allow direct drive accesses}
Procedure LockDrive(Drive: TChar);
 {Unlocks a drive to disallow direct drive accesses}
Procedure UnlockDrive(Drive: TChar);
 {Changes the current drive}
Procedure ChangeDrive(Drive: TChar);
 {Returns the current drive}
Function CurrentDrive: TChar;
 {Disables a drive, rendering it completely inaccessible until reenabled}
Procedure DisableDrive(Drive: TChar);
 {Enables a previously disabled drive}
Procedure EnableDrive(Drive: TChar);
 {Turns a FLOPPY drive's led on}
Procedure TurnLedOn(Drive: TChar);
 {Turns a FLOPPY drive's led off}
Procedure TurnLedOff(Drive: TChar);
 {Returns a drive's information}
Function DriveInformation(Drive: TChar; Var DriveType: TByte; Volume: TPointer; Var Serial,TotalSpace,FreeSpace,
                           ClusterSize: TDouble): TBoolean;
 {Returns the amount of bytes free on a drive}
Function DiskFree(Drive: TChar): TDouble;
 {Returns the total amount of bytes used on a drive}
Function DiskSize(Drive: TChar): TDouble;
 {Resets a drive, flushing its buffers}
Procedure ResetDrive(Drive: TChar);
 {Quits from the calling program}
Procedure Halt(ErrorLevel: TByte);
 {Runs another program; READ NOTE IN THE CODE ITSELF!}
Procedure Exec(Prog,Params: PChar);
 {Sets the data transfer area; not to be changed normally}
Procedure SetDTA(Address: TPointer);
 {Returns the data transfer area's address}
Function GetDTA: TPointer;
 {Finds the first file; able to process long filenames; should be
  used ONLY under Windows '95}
Procedure FindFirst95(FileSpec: PChar; Attr: TByte; Var Search: TSearch95);
 {Returns the next file; should be
  used ONLY under Windows '95}
Procedure FindNext95(Var Search: TSearch95);
 {Closes a file search; MUST be done at the end of a search; should be
  used ONLY under Windows '95}
Procedure FindClose95(Var Search: TSearch95);
 {Finds the first file}
Procedure FindFirst(FileSpec: PChar; Attr: TWord; Var Search: TSearch);
 {Finds the next file}
Procedure FindNext(Var Search: TSearch);
 {Moves 4 bytes in each move; much faster; (80386 processors
  and faster ONLY)}
Procedure Move32(Var Source,Target; Len: TWord);


Implementation uses UMulti,Strings; {This is of course the Strings unit
                                     you got with your Borland/Turbo Pascal.
                                     The UMulti unit is at the end of this
                                     file. Compile if first.}

Var DTA: TPointer;
    ParameterBlock: TPointer;
    Block: Array [1..40] Of TByte;

Procedure Move32(Var Source,Target; Len: TWord); Assembler;
Asm
  Push          Ds
  Mov           Cx,Len
  Jcxz         @End
  Lds           Si,Source
  Les           Di,Target
  Cld
  ShR           Cx,1
  Jnc          @Sw
  MovSb
 @Sw:
  Shr           Cx,1
  Jnc          @Sd
  MovSw
 @Sd:
  Db            66h,0F3h,0A5h {Rep MovSd}
 @End:
  Pop           Ds
End;

Procedure CreateDir(PathName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,7139h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,3900h
 @Use95:
  Lds           Dx,PathName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure RemoveDir(PathName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,713Ah
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,3A00h
 @Use95:
  Lds           Dx,PathName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure ChangeDir(PathName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,713Bh
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,3B00h
 @Use95:
  Lds           Dx,PathName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure CurrentDir(CurDir: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,7147h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,4700h
 @Use95:
  Xor           Dl,Dl
  Lds           Si,CurDir
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure ChangePath(PathName: PChar); Assembler;
Asm
  Push          Ds
  Lds           Si,PathName
  LodSw
  Cmp           Ah,':'
  Jne          @NoDrive
  Cmp           Al,'A'
  Jb           @NoUpper
  Cmp           Al,'Z'
  Ja           @NoUpper
  Sub           Al,20h
 @NoUpper:
  Xor           Ah,Ah
  Push          Ax
  Call          ChangeDrive
 @NoDrive:
  Lds           Si,PathName
  LodSw
  Cmp           Ah,':'
  Jne          @Added
  Dec           Si
  Dec           Si
 @Added:
  Mov           Ax,Ds
  Mov           Es,Ax
  Pop           Ds
  Push          Es
  Push          Si
  Call          ChangeDir
 @End:
End;

Procedure Subst(Drive: TChar; PathName: PChar); Assembler;
Asm
  Push          Ds
  Cmp           Using95,True
  Jne           @End
  Mov           Ax,71AAh
  Xor           Bh,Bh
  Mov           Bl,Drive
  Sub           Bl,64
  Lds           Dx,PathName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure QuerySubst(Drive: TChar; Var PathName: PChar); Assembler;
Asm
  Push          Ds
  Cmp           Using95,True
  Jne           @End
  Mov           Ax,71AAh
  Mov           Bh,02h
  Mov           Bl,Drive
  Sub           Bl,64
  Lds           Dx,PathName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure DeleteSubst(Drive: TChar); Assembler;
Asm
  Cmp           Using95,True
  Jne           @End
  Mov           Ax,71AAh
  Mov           Bh,01h
  Mov           Bl,Drive
  Sub           Bl,64
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Function Create(FileName: PChar): THandle; Assembler;
Asm
  Push          Ds
  Mov           Ax,716Ch
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,6C00h
 @Use95:
  Mov           Bl,Byte Ptr FileMode
  Mov           Bh,32
  Mov           Cx,Word Ptr CreateAttr
  Mov           Dx,0000000000010000b
  Lds           Si,FileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function Replace(FileName: PChar): THandle; Assembler;
Asm
  Push          Ds
  Mov           Ax,716Ch
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,6C00h
 @Use95:
  Mov           Bl,Byte Ptr FileMode
  Mov           Bh,32
  Mov           Cx,32
  Mov           Dx,0000000000010010b
  Lds           Si,FileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function Open(FileName: PChar): THandle; Assembler;
Asm
  Push          Ds
  Mov           Ax,716Ch
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,6C00h
 @Use95:
  Mov           Bl,Byte Ptr FileMode
  Mov           Bh,32
  Mov           Cx,32
  Mov           Dx,0000000000000001b
  Lds           Si,FileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function Duplicate(Handle: THandle): THandle; Assembler;
Asm
  Mov           Ah,45h
  Mov           Bx,Word Ptr Handle
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function Seek(Handle: THandle; Position: TDouble; Origin: TByte): TDouble; Assembler;
Asm
  Mov           Ah,42h
  Mov           Al,Byte Ptr Origin
  Mov           Bx,Word Ptr Handle
  Mov           Cx,Word Ptr Position
  Mov           Dx,Word Ptr Position+2
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function FilePos(Handle: THandle): TDouble; Assembler;
Asm
  Mov           Ah,42h
  Mov           Al,foCurrent
  Mov           Bx,Word Ptr Handle
  Xor           Cx,Cx
  Xor           Dx,Dx
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
  Xor           Dx,Dx
 @End:
End;

Function FileSize(Handle: THandle): TDouble; Assembler;
Var FPos: TDouble;
Asm
  Push          Word Ptr Handle
  Call          FilePos
  Cmp           Word Ptr flError,0
  Jne          @Error
  Mov           Word Ptr FPos,Dx
  Mov           Word Ptr FPos+2,Ax
  Mov           Ah,42h
  Mov           Al,foEnd
  Mov           Bx,Word Ptr Handle
  Xor           Cx,Cx
  Xor           Dx,Dx
  Int           21h
  Jc           @Error
  Pusha
  Mov           Ah,42h
  Mov           Al,foStart
  Mov           Bx,Word Ptr Handle
  Mov           Cx,Word Ptr FPos
  Mov           Dx,Word Ptr FPos+2
  Int           21h
  Jnc          @End
 @Error:
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
  Xor           Dx,Dx
 @End:
  Popa
End;

Function FSplit(Path,Dir,Name,Ext: PChar): TByte;
{Based on the Borland Pascal run-time library and EnhancedDos (Andrew Eigus);
 Modified for long filename support by Gil Shapira}
Var DirLen,NameLen,Flags: TWord;
    NamePtr,ExtPtr: PChar;
Begin
 NamePtr:=StrRScan(Path,'\');
 If (NamePtr=Nil) Then NamePtr:=StrRScan(Path,':');
 If (NamePtr=Nil) Then NamePtr:=Path Else Inc(NamePtr);
 ExtPtr:=StrScan(NamePtr,'.');
 If (ExtPtr=Nil) Then ExtPtr:=StrEnd(NamePtr);
 DirLen:=NamePtr-Path;
 NameLen:=ExtPtr-NamePtr;
 Flags:=0;
 If (StrScan(NamePtr,'?')<>Nil) Or (StrScan(NamePtr,'*')<>Nil) Then Flags:=fcWildcards;
 If (DirLen<>0) Then Flags:=Flags Or fcDirectory;
 If (NameLen<>0) Then Flags:=Flags Or fcFilename;
 If (ExtPtr[0]<>#0) Then Flags:=Flags Or fcExtension;
 If (Dir<>Nil) Then StrLCopy(Dir,Path,DirLen);
 If (Name<>Nil) Then StrLCopy(Name,NamePtr,NameLen);
 If (Ext<>Nil) Then StrLCopy(Ext,ExtPtr,4);
 FSplit:=Flags;
End;

Procedure FExpand(Path,Result: PChar); Assembler;
Asm
  Push            Ds
  Cld
  Lds            Si,Path
  Push          Ds
  Push          Si
  Call          StrLen
  Mov           Cx,Ax
  Add            Cx,Si
  Les            Di,Result
  LodSw
  Cmp            Si,Cx
  Ja           @1
  Cmp            Ah,':'                  {If DriveLetter not present...}
  Jne          @1                       {use default drive}
  Cmp           Al,'a'                  {If DriveLetter below 'a'...}
  Jb           @2
  Cmp            Al,'z'                  {or above 'z'...}
  Ja           @2                       {jump...}
  Sub            Al,20h                  {or else make it uppercase...}
  Jmp           @2                       {and jump}
 @1:                                    {Get current drive}
  Dec            Si
  Dec            Si
  Mov            Ah,19h
  Int            21h
  Add            Al,'A'
  Mov            Ah,':'
 @2:
  StoSw                                 {Write drive letter}
  Cmp            Si,Cx                   {If source is only drive letter...}
  Je           @21                      {jump...}
  Cmp            Byte Ptr [Si],'\'       {if it includes path...}
  Je           @3                       {jump}
 @21:                                   {Get current directory}
  Sub            Al,'A'-1
  Mov            Dl,Al
  Mov            Al,'\'
  StoSb
  Push            Si
  Push            Ds
  Mov            Ax,7147h
  Mov            Si,Di
  Push            Es
  Pop            Ds
  Int            21h
  Pop            Ds
  Pop            Si
  Jc           @3
  Cmp            Byte Ptr Es:[Di],0
  Je           @3
  Push            Cx
  Mov            Cx,-1
  Xor            Al,Al
  RepNe            ScaSb
  Dec            Di
  Mov            Al,'\'
  StoSb
  Pop            Cx
 @3:
  Sub       Cx,Si
  Rep            MovSb
  Xor            Al,Al
  StoSb
  Lds            Si,Result
  Mov            Di,Si
  Push            Di
 @4:
  LodSb
  Or            Al,Al
  Je           @6
  Cmp            Al,'\'
  Je           @6
  Cmp            Al,'a'
  Jb           @5
  Cmp            Al,'z'
  Ja           @5
 @5:
  StoSb
  Jmp           @4
 @6:
  Cmp            Word Ptr [Di-2],'.\'
  Jne           @7
  Dec            Di
  Dec            Di
  Jmp           @9
 @7:
  Cmp            Word Ptr [Di-2],'..'
  Jne           @9
  Cmp            Byte Ptr [Di-3],'\'
  Jne           @9
  Sub            Di,3
  Cmp            Byte Ptr [Di-1],':'
  Je           @9
 @8:
  Dec            Di
  Cmp            Byte Ptr [Di],'\'
  Jne           @8
 @9:
  Or            Al,Al
  Jne           @5
  Cmp            Byte Ptr [Di-1],':'
  Jne           @10
  Mov            Al,'\'
  StoSb
 @10:
  Xor           Al,Al
  StoSb
  Pop           Di
  Pop            Ds
End;

Function GetFileAttr(FileName: PChar): TByte; Assembler;
Asm
  Push          Ds
  Mov           Ax,7143h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,4300h
 @Use95:
  Xor           Bl,Bl
  Lds           Dx,FileName
  Int           21h
  Pop           Ds
  Jnc          @OK
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
  Jmp          @End
 @OK:
  Mov           Ax,Cx
 @End:
End;

Procedure SetFileAttr(FileName: PChar; Attr: TByte); Assembler;
Asm
  Push          Ds
  Mov           Ax,7143h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,4301h
 @Use95:
  Mov           Bl,01h
  Mov           Cl,Byte Ptr Attr
  Xor           Ch,Ch
  Lds           Dx,FileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure TrueName(FileName,TrueFileName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,7160h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,6000h
 @Use95:
  Mov           Cx,0002h
  Lds           Si,FileName
  Les           Di,TrueFileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure ShortName(FileName,ShortFileName: PChar); Assembler;
Asm
  Push          Ds
  Cmp           Using95,True
  Jne          @End
  Mov           Ax,7160h
  Mov           Cx,0001h
  Lds           Si,FileName
  Les           Di,ShortFileName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure LongToShort(FileName,ShortFileName: PChar); Assembler;
Asm
  Cld
  Push          Ds
  Mov           Ax,71A8h
  Cmp           Using95,True
  Jne          @End
  Lds           Si,FileName
  Les           Di,ShortFileName
  Xor           Dx,Dx
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure Delete(FileName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,7141h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,4100h
 @Use95:
  Lds           Dx,FileName
  Mov           Si,0001h
  Mov           Cl,Byte Ptr DeleteAttr
  Xor           Ch,Ch
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure Rename(FileName,NewName: PChar); Assembler;
Asm
  Push          Ds
  Mov           Ax,7156h
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,5600h
 @Use95:
  Lds           Dx,FileName
  Les           Di,NewName
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure Close(Handle: THandle); Assembler;
Asm
  Mov           Ah,3Eh
  Mov           Bx,Word Ptr Handle
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure Truncate(Handle: THandle); Assembler;
Asm
  Push          Ds
  Mov           Ah,40h
  Mov           Bx,Word Ptr Handle
  Xor           Cx,Cx
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure Commit(Handle: THandle); Assembler;
Asm
  Mov           Ah,68h
  Mov           Bx,Word Ptr Handle
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Function BlockRead(Handle: THandle; Var Buff; Count: TWord): TWord; Assembler;
Asm
  Push          Ds
  Mov           Ah,3Fh
  Mov           Bx,Word Ptr Handle
  Mov           Cx,Count
  Jcxz         @End
  Lds           Dx,Buff
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Function BlockWrite(Handle: THandle; Var Buff; Count: TWord): TWord; Assembler;
Asm
  Push          Ds
  Mov           Ah,40h
  Mov           Bx,Word Ptr Handle
  Mov           Cx,Count
  Jcxz         @End
  Lds           Dx,Buff
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Procedure LockDrive(Drive: TChar); Assembler;
Asm
  Mov           Ax,440Dh
  Mov           Cx,084Ah
  Mov           Bl,Drive
  Sub           Bl,'@'
  Mov           Bh,Byte Ptr LockLevel
  Mov           Dx,0000000000000001b
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure UnlockDrive(Drive: TChar); Assembler;
Asm
  Mov           Ax,440Dh
  Mov           Cx,086Ah
  Mov           Bl,Drive
  Sub           Bl,'@'
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure ChangeDrive(Drive: TChar); Assembler;
Asm
  Mov           Ah,0Eh
  Mov           Dl,Byte Ptr Drive
  Sub           Dl,'A'
  Int           21h
End;

Function CurrentDrive: TChar; Assembler;
Asm
  Mov           Ah,19h
  Int           21h
  Add           Al,'A'
End;

Procedure EnableDrive(Drive: TChar); Assembler;
Asm
  Mov           Ax,5F07h
  Mov           Dl,Byte Ptr Drive
  Sub           Dl,'A'
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Procedure DisableDrive(Drive: TChar); Assembler;
Asm
  Mov           Ax,5F08h
  Mov           Dl,Byte Ptr Drive
  Sub           Dl,'A'
  Int           21h
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
  Xor           Ax,Ax
 @End:
End;

Procedure FindFirst95(FileSpec: PChar; Attr: TByte; Var Search: TSearch95); Assembler;
Asm
  Push          Ds
  Mov           Ax,714Eh
  Xor           Si,Si
  Xor           Ch,Ch
  Mov           Cl,Attr
  Lds           Dx,FileSpec
  Les           Di,Search
  Inc           Di
  Inc           Di
  Int           21h
  Dec           Di
  Dec           Di
  StoSw
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure FindNext95(Var Search: TSearch95); Assembler;
Asm
  Push          Ds
  Lds           Si,Search
  LodSw
  Mov           Bx,Ax
  Mov           Ax,714Fh
  Xor           Si,Si
  Les           Di,Search
  Inc           Di
  Inc           Di
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure FindClose95(Var Search: TSearch95); Assembler;
Asm
  Push          Ds
  Lds           Si,Search
  LodSw
  Mov           Bx,Ax
  Mov           Ax,71A1h
  Int           21h
  Pop           Ds
  Jnc          @End
  Mov           flError,Ax
  Mov           isError,True
 @End:
End;

Procedure FindFirst(FileSpec: PChar; Attr: TWord; Var Search: TSearch); Assembler;
Asm
  Push          Ds
  Mov           Ah,4Eh
  Mov           Cx,Attr
  Lds           Dx,FileSpec
  Int           21h
  Jnc          @Transfer
  Mov           flError,Ax
  Mov           isError,True
  Jmp          @End
 @Transfer:
  Les           Si,DTA
  Push          Es
  Push          Si
  Les           Si,Search
  Push          Es
  Push          Si
  Push          43
  Call          Move32
 @End:
  Pop           Ds
End;

Procedure FindNext(Var Search: TSearch); Assembler;
Asm
  Push          Ds
  Les           Si,Search
  Push          Es
  Push          Si
  Les           Si,DTA
  Push          Es
  Push          Si
  Push          43
  Call          Move32
  Mov           Ah,4Fh
  Int           21h
  Jnc          @Transfer
  Mov           flError,Ax
  Mov           isError,True
  Jmp          @End
 @Transfer:
  Les           Si,DTA
  Push          Es
  Push          Si
  Les           Si,Search
  Push          Es
  Push          Si
  Push          43
  Call          Move32
 @End:
  Pop           Ds
End;

Procedure Halt(ErrorLevel: TByte); Assembler;
Asm
  Mov           Ah,4Ch
  Mov           Al,Byte Ptr ErrorLevel
  Int           21h
End;

Procedure Exec(Prog,Params: PChar); Assembler;
{For some reason, you need to add a space before the Params
 string. For example:

 To run:
   C:\COMMAND.COM /C DIR C:\
 The variables need to be like this:
   Prog:='C:\COMMAND.COM';
   Params:=' /C DIR C:\';   {Notice the space before the /C}

Var ShortFileName: PChar;
Asm
  Push          Ds
{Building ParameterBlock}
  Cld
  Les           Di,ParameterBlock
  Lds           Si,Params
  Inc           Di
  Inc           Di
  Mov           Ax,Si
  StoSw
  Mov           Ax,Ds
  StoSw
  Db            86h,0D0h,90h,86h,0C2h,86h,0C9h
  Pop           Ds
  Push          Ds
  Cmp           Using95,True
  Je           @Use95
  Lds           Dx,Prog
  Jmp          @OK
 @Use95:
{Getting short filename}
  Mov           Ax,7160h
  Mov           Cx,0001h
  Lds           Si,Prog
  Les           Di,ShortFileName
  Int           21h
  Lds           Dx,ShortFileName
  Jc           @End
{Executing}
 @OK:
  Les           Bx,ParameterBlock
  Mov           Ah,4Bh
  Xor           Al,Al
  Int           21h
 @End:
  Pop           Ds
End;

Procedure SetDTA(Address: Pointer); Assembler;
Asm
  Push          Ds
  Mov           Ah,1Ah
  Lds           Dx,Address
  Int           21h
  Pop           Ds
End;

Function GetDTA: Pointer; Assembler;
Asm
  Mov           Ah,2Fh
  Int           21h
  Mov           Dx,Es
  Mov           Ax,Bx
End;

Function DriveInformation(Drive: TChar; Var DriveType: TByte; Volume: TPointer; Var Serial,TotalSpace,FreeSpace,
                           ClusterSize: TDouble): TBoolean; Assembler;
Asm
  Push          Ds
  Mov           Ax,440Dh
  Mov           Bl,Drive
  Sub           Bl,64
  Mov           Cx,0860h
  Lds           Dx,ParameterBlock
  Int           21h
  Mov           Al,1
  Jnc          @Continue
  Xor           Al,Al
  Jmp          @Error
 @Continue:
  Mov           Si,Dx
  Inc           Si
  LodSb
  Les           Di,DriveType
  StoSb
  Pop           Ds
  Push          Ds
  Les           Di,ParameterBlock
  Xor           Ax,Ax
  StoSw
  Lds           Dx,ParameterBlock
  Mov           Ax,440Dh
  Mov           Bl,Drive
  Sub           Bl,64
  Mov           Cx,0866h
  Int           21h
  Mov           Si,Dx
  Inc           Si
  Inc           Si
  Les           Di,Serial
  Dw            0A566h
  Les           Di,Volume
  Dw            0A566h
  Dw            0A566h
  MovSw
  MovSb
  Mov           Ah,36h
  Mov           Dl,Drive
  Sub           Dl,64
  Int           21h
  Push          Dx
  Push          Ax
  Mul           Cx
  Les           Di,ClusterSize
  StoSw
  Mov           Ax,Dx
  StoSw
  Pop           Ax
  Push          Ax
  Mul           Cx
  Mul           Bx
  Les           Di,FreeSpace
  StoSw
  Mov           Ax,Dx
  StoSw
  Pop           Ax
  Pop           Dx
  Mov           Bx,Dx
  Mul           Cx
  Mul           Bx
  Les           Di,TotalSpace
  StoSw
  Mov           Ax,Dx
  StoSw
  Mov           Al,1
 @Error:
  Pop           Ds
End;

Function DiskFree(Drive: TChar): TDouble; Assembler;
Asm
  Mov           Ah,36h
  Mov           Dl,Drive
  Sub           Dl,64
  Int           21h
  Cmp           Ax,0FFFFh
  Je           @Error
  Mul           Cx
  Mul           Bx
  Jmp          @End
 @Error:
  Mov           Dx,Ax
 @End:
End;

Function DiskSize(Drive: TChar): TDouble; Assembler;
Asm
  Mov           Ah,36h
  Mov           Dl,Drive
  Sub           Dl,64
  Int           21h
  Cmp           Ax,0FFFFh
  Je           @Error
  Mul           Cx
  Mul           Dx
  Jmp          @End
 @Error:
  Mov           Dx,Ax
 @End:
End;

Procedure ResetDrive(Drive: TChar); Assembler;
Asm
  Mov           Ax,710Dh
  Cmp           Using95,True
  Je           @Use95
  Mov           Ax,0D00h
 @Use95:
  Mov           Cx,01h
  Xor           Dh,Dh
  Mov           Dl,Drive
  Sub           Dx,65
  Int           21h
End;

Procedure TurnLedOn(Drive: TChar); Assembler;
Asm
  Mov           Al,Drive
  Sub           Al,65
  Mov           Cl,Al
  Add           Cl,4
  Mov           Ah,1
  ShL           Ah,Cl
  Add           Al,Ah
  Add           Al,12
  Mov           Dx,03F2h
  Out           Dx,Al
End;

Procedure TurnLedOff(Drive: TChar); Assembler;
Asm
  Mov           Al,Drive
  Sub           Al,53
  Mov           Dx,03F2h
  Out           Dx,Al
End;


Begin
 CreateAttr:=faArchive;
 FindAttr:=faArchive Or faReadOnly;
 CopyAttr:=faArchive Or faReadOnly;
 DeleteAttr:=faArchive;
 FileMode:=fmReadWrite;
 FillChar(Block,40,$00);
 ParameterBlock:=@Block;
 LockLevel:=0;
 Using95:=(Task.OS=osWin95);
 DTA:=GetDTA;
End.

(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)
(* UMulti - multitasker support unit *)
(*        Compile this first         *)

Unit UMulti;

Interface uses UGlobal;

Const Tasker: Array [0..10] Of String[9] = ('DOS','Windows ''95','Windows','OS/2','DesqView','TopView','DoubleDos',
                                            'NetWare','MultiLink','CSwitch','EuroDOS');

Const osDOS = 0;
      osWin95 = 1;
      osWindows = 2;
      osOS2 = 3;
      osDesqView = 4;
      osTopView = 5;
      osDoubleDos = 6;
      osNetWare = 7;
      osMultiLink = 8;
      osCSwitch = 9;
      osEuroDOS = 10;

Type TaskRec = Record
      OS: Word;
      Version: Word;
      Delay: Word;
     End;

Const Task: TaskRec = (OS: 0;
                       Version: 0;
                       Delay: 100);

{ Call  GiveTimeSlice  to release CPU cycles to the multitasker. }

{ Polling  could be use as procedure to be used inside ReadKey procedures
  to read the clock, update the screen, and release CPU cycles. Polling is
  at startup the same as GiveTimeSlice }

Var GiveTimeSlice,
    Polling: TProc;

{ AssignProcs  is called automatically by the startup procedure Init }
Procedure AssignProcs;

{ ReleaseTime is a macro procedure which takes only 7 bytes, and releases
  DOS, Windows, Windows '95, and OS/2 timeslices }
Procedure ReleaseTime; Inline($CD/$28/$B8/$80/$16/$CD/$2F);

Implementation

{$F+}
Procedure NetWare_GTS; Assembler;
Asm
  Mov           Bx,000Ah
  Int           7Ah
End;

Procedure DoubleDOS_GTS; Assembler;
Asm
  Mov           Ax,0EE02h
  Int           21h
End;

Procedure Windows_Win95_OS2_GTS; Assembler;
Asm
  Mov           Ax,1680h
  Int           2Fh
End;

Procedure DesqView_TopView_GTS; Assembler;
Asm
  Mov           Ax,1000h
  Int           15h
End;

Procedure DOS_GTS; Assembler;
Asm
  Int           28h
End;

Procedure MultiLink_GTS; Assembler;
Asm
  Mov           Ah,02h
  Int           7Fh
End;

Procedure CSwitch_GTS; Assembler;
Asm
  Mov           Ah,01h
  Int           62h
End;

Procedure EuroDOS_GTS; Assembler;
Asm
  Mov           Ah,89h
  Xor           Cx,Cx
  Int           21h
End;
{$F-}

Procedure AssignProcs;
Begin
 Case Task.OS Of
  osDos: GiveTimeSlice:=DOS_GTS;
  osWin95: GiveTimeSlice:=Windows_Win95_OS2_GTS;
  osWindows: GiveTimeSlice:=Windows_Win95_OS2_GTS;
  osOS2: GiveTimeSlice:=Windows_Win95_OS2_GTS;
  osDesqView: GiveTimeSlice:=DesqView_TopView_GTS;
  osTopView: GiveTimeSlice:=DesqView_TopView_GTS;
  osDoubleDos: GiveTimeSlice:=DoubleDOS_GTS;
  osNetWare: GiveTimeSlice:=NetWare_GTS;
  osMultiLink: GiveTimeSlice:=MultiLink_GTS;
  osCSwitch: GiveTimeSlice:=CSwitch_GTS;
  osEuroDOS: GiveTimeSlice:=EuroDOS_GTS;
 End;
End;

Procedure Init; Assembler;
Asm
  Mov           Task.OS,00h
  Mov           Task.Version,00h
  Mov           Ah,87h
  Xor           Al,Al
  Int           21h
  Cmp           Al,0
  Jne          @EuroDOS
  Mov           Ah,30h
  Mov           Al,01h
  Int           21h
  Cmp           Al,14h
  Je           @OS2
  Mov           Ax,160Ah
  Int           2Fh
  Cmp           Ax,00h
  Je           @Windows
  Mov           Ax,1022h
  Mov           Bx,0000h
  Int           15h
  Cmp           Bx,00h
  Jne          @DesqView
  Mov           Ah,2Bh
  Mov           Al,01h
  Mov           Cx,4445h
  Mov           Dx,5351h
  Int           21h
  Cmp           Al,0FFh
  Jne          @TopView
  Mov           Ax,0E400h
  Int           21h
  Cmp           Al,00h
  Jne          @DoubleDos
  Mov           Ax,7A00h
  Int           2Fh
  Cmp           Al,0FFh
  Je           @NetWare
  Jmp          @End
 @Windows:
  Cmp           Bh,04h
  Jne          @Win3
  Mov           Task.OS,01h
  Jmp          @Windows_OK
 @Win3:
  Mov           Task.OS,02h
 @Windows_OK:
  Mov           Task.Version,Bx
  Jmp          @End
 @OS2:
  Mov           Task.OS,03h
  Mov           Bh,Ah
  Xor           Ah,Ah
  Mov           Cl,0Ah
  Div           Cl
  Mov           Ah,Bh
  XChg          Ah,Al
  Mov           Task.Version,Ax
  Jmp          @End
 @DesqView:
  Mov           Task.OS,04h
  Jmp          @End
 @TopView:
  Mov           Task.OS,05h
  Jmp          @End
 @DoubleDos:
  Mov           Task.OS,06h
  Jmp          @End
 @NetWare:
  Mov           Task.OS,07h
  Jmp          @End
 @MultiLink:
  Mov           Task.OS,08h
  Jmp          @End
 @CSwitch:
  Mov           Task.OS,09h
  Jmp          @End
 @EuroDOS:
  Mov           Task.OS,10h
 @End:
  Call          AssignProcs
End;

Begin
 Init;
 Polling:=GiveTimeSlice;
End.